home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / parse-time.lisp < prev    next >
Encoding:
Text File  |  1992-05-30  |  23.3 KB  |  608 lines
  1. ;;;  -*- Mode: Lisp; Package: Extensions; Log: code.log -*-
  2.  
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: parse-time.lisp,v 1.3 91/07/26 11:35:16 chiles Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13.  
  14. ;;; Parsing routines for time and date strings. Parse-time returns the
  15. ;;; universal time integer for the time and/or date given in the string.
  16.  
  17. ;;; Written by Jim Healy, June 1987.
  18.  
  19. ;;; **********************************************************************
  20.  
  21. (in-package "EXTENSIONS" :use "LISP")
  22.  
  23. (export 'parse-time)
  24.  
  25. (defconstant whitespace-chars '(#\space #\tab #\newline #\, #\' #\`))
  26. (defconstant time-dividers '(#\: #\.))
  27. (defconstant date-dividers '(#\\ #\/ #\-))
  28.  
  29. (defvar *error-on-mismatch* nil
  30.   "If t, an error will be signalled if parse-time is unable
  31.    to determine the time/date format of the string.")
  32.  
  33. ;;; Set up hash tables for month, weekday, zone, and special strings.
  34. ;;; Provides quick, easy access to associated information for these items.
  35.  
  36. ;;; Hashlist takes an association list and hashes each pair into the
  37. ;;; specified tables using the car of the pair as the key and the cdr as
  38. ;;; the data object.
  39.  
  40. (defmacro hashlist (list table)
  41.   `(dolist (item ,list)
  42.      (setf (gethash (car item) ,table) (cdr item))))
  43.  
  44. (defparameter weekday-table-size 23)
  45. (defparameter month-table-size 31)
  46. (defparameter zone-table-size 11)
  47. (defparameter special-table-size 11)
  48.  
  49. (defvar *weekday-strings* (make-hash-table :test #'equal
  50.                      :size weekday-table-size))
  51.  
  52. (defvar *month-strings* (make-hash-table :test #'equal
  53.                        :size month-table-size))
  54.  
  55. (defvar *zone-strings* (make-hash-table :test #'equal
  56.                       :size zone-table-size))
  57.  
  58. (defvar *special-strings* (make-hash-table :test #'equal
  59.                      :size special-table-size))
  60.  
  61. ;;; Load-time creation of the hash tables.
  62.  
  63. (hashlist '(("monday" . 0)    ("mon" . 0)
  64.         ("tuesday" . 1)   ("tues" . 1)   ("tue" . 1)
  65.         ("wednesday" . 2) ("wednes" . 2) ("wed" . 2)
  66.         ("thursday" . 3)  ("thurs" . 3)  ("thu" . 3)
  67.         ("friday" . 4)    ("fri" . 4)
  68.         ("saturday" . 5)  ("sat" . 5)
  69.         ("sunday" . 6)    ("sun" . 6))
  70.       *weekday-strings*)
  71.  
  72. (hashlist '(("january" . 1)   ("jan" . 1)
  73.         ("february" . 2)  ("feb" . 2)
  74.         ("march" . 3)     ("mar" . 3)
  75.         ("april" . 4)     ("apr" . 4)
  76.         ("may" . 5)       ("june" . 6)
  77.         ("jun" . 6)       ("july" . 7)
  78.         ("jul" . 7)          ("august" . 8)
  79.         ("aug" . 8)       ("september" . 9)
  80.         ("sept" . 9)      ("sep" . 9)
  81.         ("october" . 10)  ("oct" . 10)
  82.         ("november" . 11) ("nov" . 11)
  83.         ("december" . 12) ("dec" . 12))
  84.       *month-strings*)
  85.  
  86. (hashlist '(("gmt" . 0) ("est" . 5)
  87.         ("edt" . 4) ("cst" . 6)
  88.         ("cdt" . 5) ("mst" . 7)
  89.         ("mdt" . 6)    ("pst" . 8)
  90.         ("pdt" . 7)) 
  91.       *zone-strings*)
  92.  
  93. (hashlist '(("yesterday" . yesterday)  ("today" . today)
  94.         ("tomorrow" . tomorrow)   ("now" . now))
  95.       *special-strings*)
  96.  
  97. ;;; Time/date format patterns are specified as lists of symbols repre-
  98. ;;; senting the elements.  Optional elements can be specified by
  99. ;;; enclosing them in parentheses.  Note that the order in which the
  100. ;;; patterns are specified below determines the order of search.
  101.  
  102. ;;; Choices of pattern symbols are: second, minute, hour, day, month,
  103. ;;; year, time-divider, date-divider, am-pm, zone, weekday, noon-midn,
  104. ;;; and any special symbol.
  105.  
  106. (defparameter patterns
  107.   '( 
  108.      ;; Date formats.
  109.     ((weekday) month (date-divider) day (date-divider) year (noon-midn))
  110.     ((weekday) day (date-divider) month (date-divider) year (noon-midn))
  111.     ((weekday) month (date-divider) day (noon-midn))
  112.     (year (date-divider) month (date-divider) day (noon-midn))
  113.     (month (date-divider) year (noon-midn))
  114.     (year (date-divider) month (noon-midn))
  115.  
  116.     ((noon-midn) (weekday) month (date-divider) day (date-divider) year)
  117.     ((noon-midn) (weekday) day (date-divider) month (date-divider) year)
  118.     ((noon-midn) (weekday) month (date-divider) day)
  119.     ((noon-midn) year (date-divider) month (date-divider) day)
  120.     ((noon-midn) month (date-divider) year)
  121.     ((noon-midn) year (date-divider) month)
  122.  
  123.      ;; Time formats.
  124.     (hour (time-divider) (minute) (time-divider) (secondp) (am-pm) 
  125.       (date-divider) (zone))
  126.     (noon-midn)
  127.     (hour (noon-midn))
  128.  
  129.      ;; Time/date combined formats.
  130.     ((weekday) month (date-divider) day (date-divider) year
  131.        hour (time-divider) (minute) (time-divider) (secondp)
  132.        (am-pm) (date-divider) (zone))
  133.     ((weekday) day (date-divider) month (date-divider) year
  134.      hour (time-divider) (minute) (time-divider) (secondp)
  135.      (am-pm) (date-divider) (zone))
  136.     ((weekday) month (date-divider) day
  137.        hour (time-divider) (minute) (time-divider) (secondp)
  138.        (am-pm) (date-divider) (zone))
  139.     (year (date-divider) month (date-divider) day
  140.       hour (time-divider) (minute) (time-divider) (secondp)
  141.       (am-pm) (date-divider) (zone))
  142.     (month (date-divider) year
  143.        hour (time-divider) (minute) (time-divider) (secondp)
  144.        (am-pm) (date-divider) (zone))
  145.     (year (date-divider) month
  146.       hour (time-divider) (minute) (time-divider) (secondp)
  147.       (am-pm) (date-divider) (zone))
  148.  
  149.     (hour (time-divider) (minute) (time-divider) (secondp) (am-pm)
  150.       (date-divider) (zone) (weekday) month (date-divider)
  151.       day (date-divider) year)
  152.     (hour (time-divider) (minute) (time-divider) (secondp) (am-pm)
  153.       (date-divider) (zone) (weekday) day (date-divider)
  154.       month (date-divider) year)
  155.     (hour (time-divider) (minute) (time-divider) (secondp) (am-pm)
  156.       (date-divider) (zone) (weekday) month (date-divider)
  157.       day)
  158.     (hour (time-divider) (minute) (time-divider) (secondp) (am-pm)
  159.       (date-divider) (zone) year (date-divider) month
  160.       (date-divider) day)
  161.     (hour (time-divider) (minute) (time-divider) (secondp) (am-pm)
  162.       (date-divider) (zone) month (date-divider) year)
  163.     (hour (time-divider) (minute) (time-divider) (secondp) (am-pm)
  164.       (date-divider) (zone) year (date-divider) month)
  165.  
  166.      ;; Weird, non-standard formats.
  167.     (weekday month day hour (time-divider) minute (time-divider)
  168.          secondp (am-pm)
  169.          (zone) year)
  170.     ((weekday) day (date-divider) month (date-divider) year hour
  171.      (time-divider) minute (time-divider) (secondp) (am-pm)
  172.      (date-divider) (zone))
  173.     ((weekday) month (date-divider) day (date-divider) year hour
  174.      (time-divider) minute (time-divider) (secondp) (am-pm)
  175.      (date-divider) (zone))
  176.  
  177.     ;; Special-string formats.
  178.     (now (yesterday))
  179.     ((yesterday) now)
  180.     (now (today))
  181.     ((today) now)
  182.     (now (tomorrow))
  183.     ((tomorrow) now)
  184.     (yesterday (noon-midn))
  185.     ((noon-midn) yesterday)
  186.     (today (noon-midn))
  187.     ((noon-midn) today)
  188.     (tomorrow (noon-midn))
  189.     ((noon-midn) tomorrow)
  190. ))
  191.  
  192. ;;; The decoded-time structure holds the time/date values which are
  193. ;;; eventually passed to 'encode-universal-time' after parsing.
  194.  
  195. ;;; Note: Currently nothing is done with the day of the week.  It might
  196. ;;; be appropriate to add a function to see if it matches the date.
  197.  
  198. (defstruct decoded-time
  199.   (second 0    :type integer)    ; Value between 0 and 59.
  200.   (minute 0    :type integer)    ; Value between 0 and 59.
  201.   (hour   0    :type integer)    ; Value between 0 and 23.
  202.   (day    1    :type integer)    ; Value between 1 and 31.
  203.   (month  1    :type integer)    ; Value between 1 and 12.
  204.   (year   1900 :type integer)    ; Value above 1899 or between 0 and 99.
  205.   (zone   0    :type integer)    ; Value between 0 and 23.
  206.   (dotw   0    :type integer))   ; Value between 0 and 6.
  207.  
  208. ;;; Make-default-time returns a decoded-time structure with the default
  209. ;;; time values already set.  The default time is currently 00:00 on
  210. ;;; the current day, current month, current year, and current time-zone.
  211.  
  212. (defun make-default-time (def-sec def-min def-hour def-day
  213.                def-mon def-year def-zone def-dotw)
  214.   (let ((default-time (make-decoded-time)))
  215.     (multiple-value-bind (sec min hour day mon year dotw dst zone)
  216.              (get-decoded-time)
  217.       (declare (ignore dst))
  218.       (if def-sec
  219.       (if (eq def-sec :current)
  220.           (setf (decoded-time-second default-time) sec)
  221.           (setf (decoded-time-second default-time) def-sec))
  222.       (setf (decoded-time-second default-time) 0))
  223.       (if def-min
  224.       (if (eq def-min :current)
  225.           (setf (decoded-time-minute default-time) min)
  226.           (setf (decoded-time-minute default-time) def-min))
  227.       (setf (decoded-time-minute default-time) 0))
  228.       (if def-hour
  229.       (if (eq def-hour :current)
  230.           (setf (decoded-time-hour default-time) hour)
  231.           (setf (decoded-time-hour default-time) def-hour))
  232.       (setf (decoded-time-hour default-time) 0))
  233.       (if def-day
  234.       (if (eq def-day :current)
  235.           (setf (decoded-time-day default-time) day)
  236.           (setf (decoded-time-day default-time) def-day))
  237.       (setf (decoded-time-day default-time) day))
  238.       (if def-mon
  239.       (if (eq def-mon :current)
  240.           (setf (decoded-time-month default-time) mon)
  241.           (setf (decoded-time-month default-time) def-mon))
  242.       (setf (decoded-time-month default-time) mon))
  243.       (if def-year
  244.       (if (eq def-year :current)
  245.           (setf (decoded-time-year default-time) year)
  246.           (setf (decoded-time-year default-time) def-year))
  247.       (setf (decoded-time-year default-time) year))
  248.       (if def-zone
  249.       (if (eq def-zone :current)
  250.           (setf (decoded-time-zone default-time) zone)
  251.           (setf (decoded-time-zone default-time) def-zone))
  252.       (setf (decoded-time-zone default-time) zone))
  253.       (if def-dotw
  254.       (if (eq def-dotw :current)
  255.           (setf (decoded-time-dotw default-time) dotw)
  256.           (setf (decoded-time-dotw default-time) def-dotw))
  257.       (setf (decoded-time-dotw default-time) dotw))
  258.       default-time)))
  259.  
  260. ;;; Converts the values in the decoded-time structure to universal time
  261. ;;; by calling extensions:encode-universal-time.
  262. ;;; If zone is in numerical form, tweeks it appropriately.
  263.  
  264. (defun convert-to-unitime (parsed-values)
  265.   (let ((zone (decoded-time-zone parsed-values)))
  266.     (encode-universal-time (decoded-time-second parsed-values)
  267.                (decoded-time-minute parsed-values)
  268.                (decoded-time-hour parsed-values)
  269.                (decoded-time-day parsed-values)
  270.                (decoded-time-month parsed-values)
  271.                (decoded-time-year parsed-values)
  272.                (if (or (> zone 23) (< zone -23))
  273.                    (let ((new-zone (/ zone 100)))
  274.                  (cond ((minusp new-zone) (- new-zone))
  275.                        ((plusp new-zone) (- 24 new-zone))
  276.                        ;; must be zero (GMT)
  277.                        (t new-zone)))
  278.                    zone))))
  279.  
  280. ;;; Sets the current values for the time and/or date parts of the 
  281. ;;; decoded time structure.
  282.  
  283. (defun set-current-value (values-structure &key (time nil) (date nil) (zone nil))
  284.   (multiple-value-bind (sec min hour day mon year dotw dst tz)
  285.                (get-decoded-time)
  286.     (declare (ignore dst))
  287.     (when time
  288.       (setf (decoded-time-second values-structure) sec)
  289.       (setf (decoded-time-minute values-structure) min)
  290.       (setf (decoded-time-hour values-structure) hour))
  291.     (when date
  292.       (setf (decoded-time-day values-structure) day)
  293.       (setf (decoded-time-month values-structure) mon)
  294.       (setf (decoded-time-year values-structure) year)
  295.       (setf (decoded-time-dotw values-structure) dotw))
  296.     (when zone
  297.       (setf (decoded-time-zone values-structure) tz))))
  298.  
  299. ;;; Special function definitions.  To define a special substring, add
  300. ;;; a dotted pair consisting of the substring and a symbol in the
  301. ;;; *special-strings* hashlist statement above.  Then define a function
  302. ;;; here which takes one argument- the decoded time structure- and
  303. ;;; sets the values of the structure to whatever is necessary.  Also,
  304. ;;; add a some patterns to the patterns list using whatever combinations
  305. ;;; of special and pre-existing symbols desired.
  306.  
  307. (defun yesterday (parsed-values)
  308.   (set-current-value parsed-values :date t :zone t)
  309.   (setf (decoded-time-day parsed-values)
  310.     (1- (decoded-time-day parsed-values))))
  311.  
  312. (defun today (parsed-values)
  313.   (set-current-value parsed-values :date t :zone t))
  314.  
  315. (defun tomorrow (parsed-values)
  316.   (set-current-value parsed-values :date t :zone t)
  317.   (setf (decoded-time-day parsed-values)
  318.     (1+ (decoded-time-day parsed-values))))
  319.  
  320. (defun now (parsed-values)
  321.   (set-current-value parsed-values :time t))
  322.  
  323. ;;; Predicates for symbols.  Each symbol has a corresponding function
  324. ;;; defined here which is applied to a part of the datum to see if
  325. ;;; it matches the qualifications.
  326.  
  327. (defun am-pm (string)
  328.   (and (simple-string-p string)
  329.        (cond ((string= string "am") 'am)
  330.          ((string= string "pm") 'pm)
  331.          (t nil))))
  332.  
  333. (defun noon-midn (string)
  334.   (and (simple-string-p string)
  335.        (cond ((string= string "noon") 'noon)
  336.          ((string= string "midnight") 'midn)
  337.          (t nil))))
  338.  
  339. (defun weekday (string)
  340.   (and (simple-string-p string) (gethash string *weekday-strings*)))
  341.  
  342. (defun month (thing)
  343.   (or (and (simple-string-p thing) (gethash thing *month-strings*))
  344.       (and (integerp thing) (<= 1 thing 12))))
  345.  
  346. (defun zone (thing)
  347.   (or (and (simple-string-p thing) (gethash thing *zone-strings*))
  348.       (if (integerp thing)
  349.       (let ((zone (/ thing 100)))
  350.         (and (integerp zone) (<= -23 zone 23))))))
  351.  
  352. (defun special (string)
  353.   (and (simple-string-p string) (gethash string *special-strings*)))
  354.  
  355. (defun secondp (number)
  356.   (and (integerp number) (<= 0 number 59)))
  357.  
  358. (defun minute (number)
  359.   (and (integerp number) (<= 0 number 59)))
  360.  
  361. (defun hour (number)
  362.   (and (integerp number) (<= 0 number 23)))
  363.  
  364. (defun day (number)
  365.   (and (integerp number) (<= 1 number 31)))
  366.  
  367. (defun year (number)
  368.   (and (integerp number)
  369.        (or (<= 0 number 99)
  370.        (<= 1900 number))))
  371.  
  372. (defun time-divider (character)
  373.   (and (characterp character)
  374.        (member character time-dividers :test #'char=)))
  375.  
  376. (defun date-divider (character)
  377.   (and (characterp character)
  378.        (member character date-dividers :test #'char=)))
  379.  
  380. ;;; Match-substring takes a string argument and tries to match it with
  381. ;;; the strings in one of the four hash tables: *weekday-strings*, *month-
  382. ;;; strings*, *zone-strings*, *special-strings*.  It returns a specific
  383. ;;; keyword and/or the object it finds in the hash table.  If no match
  384. ;;; is made then it immediately signals an error.
  385.  
  386. (defun match-substring (substring)
  387.   (let ((substring (nstring-downcase substring)))
  388.     (or (let ((test-value (month substring)))
  389.       (if test-value (cons 'month test-value)))
  390.     (let ((test-value (weekday substring)))
  391.       (if test-value (cons 'weekday test-value)))
  392.     (let ((test-value (am-pm substring)))
  393.       (if test-value (cons 'am-pm test-value)))
  394.     (let ((test-value (noon-midn substring)))
  395.       (if test-value (cons 'noon-midn test-value)))
  396.     (let ((test-value (zone substring)))
  397.       (if test-value (cons 'zone test-value)))
  398.     (let ((test-value (special substring)))
  399.       (if test-value  (cons 'special test-value)))
  400.     (if *error-on-mismatch*
  401.         (error "\"~A\" is not a recognized word or abbreviation."
  402.            substring)
  403.         (return-from match-substring nil)))))
  404.  
  405. ;;; Decompose-string takes the time/date string and decomposes it into a
  406. ;;; list of alphabetic substrings, numbers, and special divider characters.
  407. ;;; It matches whatever strings it can and replaces them with a dotted pair
  408. ;;; containing a symbol and value.
  409.  
  410. (defun decompose-string (string &key (start 0) (end (length string)) (radix 10))
  411.   (do ((string-index start)
  412.        (next-negative nil)
  413.        (parts-list nil))
  414.       ((eq string-index end) (nreverse parts-list))
  415.     (let ((next-char (char string string-index))
  416.       (prev-char (if (= string-index start)
  417.              nil
  418.              (char string (1- string-index)))))
  419.       (cond ((alpha-char-p next-char)
  420.          ;; Alphabetic character - scan to the end of the substring.
  421.          (do ((scan-index (1+ string-index) (1+ scan-index)))
  422.          ((or (eq scan-index end)
  423.               (not (alpha-char-p (char string scan-index))))
  424.           (let ((match-symbol (match-substring
  425.                        (subseq string string-index scan-index))))
  426.             (if match-symbol
  427.             (push match-symbol parts-list)
  428.             (return-from decompose-string nil)))
  429.           (setf string-index scan-index))))
  430.         ((digit-char-p next-char radix)
  431.          ;; Numeric digit - convert digit-string to a decimal value.
  432.          (do ((scan-index string-index (1+ scan-index))
  433.           (numeric-value 0 (+ (* numeric-value radix)
  434.                       (digit-char-p (char string scan-index) radix))))
  435.          ((or (eq scan-index end)
  436.               (not (digit-char-p (char string scan-index) radix)))
  437.           ;; If next-negative is t, set the numeric value to it's
  438.           ;; opposite and reset next-negative to nil.
  439.           (when next-negative
  440.             (setf next-negative nil)
  441.             (setf numeric-value (- numeric-value)))
  442.           (push numeric-value parts-list)
  443.           (setf string-index scan-index))))
  444.         ((and (char= next-char #\-)
  445.           (or (not prev-char)
  446.               (member prev-char whitespace-chars :test #'char=)))
  447.          ;; If we see a minus sign before a number, but not after one,
  448.          ;; it is not a date divider, but a negative offset from GMT, so
  449.          ;; set next-negative to t and continue.
  450.          (setf next-negative t)
  451.          (incf string-index))         
  452.         ((member next-char time-dividers :test #'char=)
  453.           ;; Time-divider - add it to the parts-list with symbol.
  454.          (push (cons 'time-divider next-char) parts-list)
  455.          (incf string-index))
  456.         ((member next-char date-dividers :test #'char=)
  457.          ;; Date-divider - add it to the parts-list with symbol.
  458.          (push (cons 'date-divider next-char) parts-list)
  459.          (incf string-index))
  460.         ((member next-char whitespace-chars :test #'char=)
  461.          ;; Whitespace character - ignore it completely.
  462.          (incf string-index))
  463.         ((char= next-char #\()
  464.          ;; Parenthesized string - scan to the end and ignore it.
  465.          (do ((scan-index string-index (1+ scan-index)))
  466.          ((or (eq scan-index end)
  467.               (char= (char string scan-index) #\)))
  468.            (setf string-index (1+ scan-index)))))
  469.         (t
  470.          ;; Unrecognized character - barf voraciously.
  471.          (if *error-on-mismatch*
  472.          (error (concatenate 'simple-string ">>> " string
  473.                      "~%~VT^-- Bogus character encountered here.")
  474.             (+ string-index 4))
  475.          (return-from decompose-string nil)))))))
  476.  
  477. ;;; Match-pattern-element tries to match a pattern element with a datum
  478. ;;; element and returns the symbol associated with the datum element if
  479. ;;; successful.  Otherwise nil is returned.
  480.  
  481. (defun match-pattern-element (pattern-element datum-element)
  482.   (cond ((listp datum-element)
  483.      (let ((datum-type (if (eq (car datum-element) 'special)
  484.                    (cdr datum-element)
  485.                    (car datum-element))))
  486.        (if (eq datum-type pattern-element) datum-element)))
  487.     ((funcall pattern-element datum-element)
  488.      (cons pattern-element datum-element))
  489.     (t nil)))
  490.  
  491. ;;; Match-pattern matches a pattern against a datum, returning the
  492. ;;; pattern if successful and nil otherwise.
  493.  
  494. (defun match-pattern (pattern datum datum-length)
  495.   (if (>= (length pattern) datum-length)
  496.       (let ((form-list nil))
  497.     (do ((pattern pattern (cdr pattern))
  498.          (datum datum (cdr datum)))
  499.         ((or (null pattern) (null datum))
  500.          (cond ((and (null pattern) (null datum))
  501.             (nreverse form-list))
  502.            ((null pattern) nil)
  503.            ((null datum) (dolist (element pattern
  504.                           (nreverse form-list))
  505.                    (if (not (listp element))
  506.                        (return nil))))))
  507.       (let* ((pattern-element (car pattern))
  508.          (datum-element (car datum))
  509.          (optional (listp pattern-element))
  510.          (matching (match-pattern-element (if optional
  511.                               (car pattern-element)
  512.                               pattern-element)
  513.                           datum-element)))
  514.         (cond (matching (let ((form-type (car matching)))
  515.                   (unless (or (eq form-type 'time-divider)
  516.                       (eq form-type 'date-divider))
  517.                 (push matching form-list))))
  518.           (optional (push datum-element datum))
  519.           (t (return-from match-pattern nil))))))))
  520.  
  521. ;;; Deal-with-noon-midn sets the decoded-time values to either noon
  522. ;;; or midnight depending on the argument form-value.  Form-value
  523. ;;; can be either 'noon or 'midn.
  524.  
  525. (defun deal-with-noon-midn (form-value parsed-values)
  526.   (cond ((eq form-value 'noon)
  527.      (setf (decoded-time-hour parsed-values) 12))
  528.     ((eq form-value 'midn)
  529.      (setf (decoded-time-hour parsed-values) 0))
  530.     (t (error "Unrecognized symbol: ~A" form-value)))
  531.   (setf (decoded-time-minute parsed-values) 0)
  532.   (setf (decoded-time-second parsed-values) 0))
  533.  
  534. ;;; Deal-with-am-pm sets the decoded-time values to be in the am
  535. ;;; or pm depending on the argument form-value.  Form-value can
  536. ;;; be either 'am or 'pm.
  537.  
  538. (defun deal-with-am-pm (form-value parsed-values)
  539.   (let ((hour (decoded-time-hour parsed-values)))
  540.     (cond ((eq form-value 'am)
  541.        (cond ((eq hour 12)
  542.           (setf (decoded-time-hour parsed-values) 0))
  543.          ((not (<= 0 hour 12))
  544.           (if *error-on-mismatch*
  545.               (error "~D is not an AM hour, dummy." hour)))))
  546.       ((eq form-value 'pm)
  547.        (if (<= 0 hour 11)
  548.            (setf (decoded-time-hour parsed-values)
  549.              (mod (+ hour 12) 24))))
  550.       (t (error "~A isn't AM/PM - this shouldn't happen.")))))
  551.  
  552. ;;; Set-time-values uses the association list of symbols and values
  553. ;;; to set the time in the decoded-time structure.
  554.  
  555. (defun set-time-values (string-form parsed-values)
  556.   (dolist (form-part string-form t)
  557.     (let ((form-type (car form-part))
  558.       (form-value (cdr form-part)))
  559.       (case form-type
  560.     (secondp (setf (decoded-time-second parsed-values) form-value))
  561.     (minute (setf (decoded-time-minute parsed-values) form-value))
  562.     (hour (setf (decoded-time-hour parsed-values) form-value))
  563.     (day (setf (decoded-time-day parsed-values) form-value))
  564.     (month (setf (decoded-time-month parsed-values) form-value))
  565.     (year (setf (decoded-time-year parsed-values) form-value))
  566.     (zone (setf (decoded-time-zone parsed-values) form-value))
  567.     (weekday (setf (decoded-time-dotw parsed-values) form-value))
  568.     (am-pm (deal-with-am-pm form-value parsed-values))
  569.     (noon-midn (deal-with-noon-midn form-value parsed-values))
  570.     (special (funcall form-value parsed-values))
  571.     (t (error "Unrecognized symbol in form list: ~A." form-type))))))
  572.  
  573. (defun parse-time (time-string &key (start 0) (end (length time-string))
  574.                    (error-on-mismatch nil)                   
  575.                    (default-seconds nil) (default-minutes nil)
  576.                    (default-hours nil) (default-day nil)
  577.                    (default-month nil) (default-year nil)
  578.                    (default-zone nil) (default-weekday nil))
  579.   "Tries very hard to make sense out of the argument time-string and
  580.    returns a single integer representing the universal time if
  581.    successful.  If not, it returns nil.  If the :error-on-mismatch
  582.    keyword is true, parse-time will signal an error instead of
  583.    returning nil.  Default values for each part of the time/date
  584.    can be specified by the appropriate :default- keyword.  These
  585.    keywords can be given a numeric value or the keyword :current
  586.    to set them to the current value.  The default-default values
  587.    are 00:00:00 on the current date, current time-zone."
  588.   (setq *error-on-mismatch* error-on-mismatch)
  589.   (let* ((string-parts (decompose-string time-string :start start :end end))
  590.      (parts-length (length string-parts))
  591.      (string-form (dolist (pattern patterns)
  592.             (let ((match-result (match-pattern pattern
  593.                                string-parts
  594.                                parts-length)))
  595.               (if match-result (return match-result))))))
  596.     (if string-form
  597.     (let ((parsed-values (make-default-time default-seconds default-minutes
  598.                         default-hours default-day
  599.                         default-month default-year
  600.                         default-zone default-weekday)))
  601.       (set-time-values string-form parsed-values)
  602.       (convert-to-unitime parsed-values))
  603.     (if *error-on-mismatch*
  604.       (error "\"~A\" is not a recognized time/date format." time-string)
  605.       nil))))
  606.  
  607.  
  608.